#!/usr/bin/env perl
# Copyright (c) 2021-2024 Huawei Device Co., Ltd.
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
# Validator and dumper of cookbook recipes

use 5.010;
use strict;
use warnings;

use constant false => 0;
use constant true  => 1;

my %skip_list_snippets = (
    54 => { # JSX, no reasonable example
        code_ok  => 1,
        code_bad => 1,
    },
    144 => { # Standard library limitations, no reasonable example
        code_ok  => 1,
        code_bad => 1,
    },
    149 => {
        code_ok  => 1, # Classes as object, no reasonable example
        code_bad => 0,
    },
    158 => {
        code_ok  => 1, # Sendable class decorators, no reasonable example
        code_bad => 0,
    },
);

sub recipe_init
{
    my $id = shift;

    my $r = {
        id            => $id,
        desc_brief    => '',
        desc_detailed => [],
        short_name    => '',
        severity      => undef,
        linter_ids    => [],
        code_bad      => [],
        code_ok       => [],
        see_also      => [],
    };
    my %seen = map { ($_ => 0) } keys %$r;
    $r->{seen} = \%seen;
    foreach my $code ('code_bad', 'code_ok') {
        $r->{seen}{"${code}_block"} = 0;
    }
    return $r;
}

sub recipe_add_desc_brief
{
    my $r = shift;
    my $desc_brief = shift;

    die 'Unable to redefine desc_brief' if $r->{seen}{desc_brief};

    $r->{desc_brief} = $desc_brief;
    $r->{seen}{desc_brief} = 1;
}

sub recipe_add_short_name
{
    my $r = shift;
    my $short_name = shift;

    die 'Unable to redefine short_name' if $r->{seen}{short_name};

    if ($short_name =~ /^arkts-no/ && $short_name !~ /^arkts-no-/) {
        die 'Style: Instead of arkts-nosomething, use arkts-nosomething'
    }
    # Just to make short names a bit shorter (yet readable), if possible:
    my %shorter_names = (
        array       => 'arr',
        constructor => 'ctor',
        declaration => 'decl',
        function    => 'func',
        interface   => 'iface',
        object      => 'obj',
        parameter   => 'param',
        propert     => 'prop', # -ty, -ties :)
        string      => 'str',
    );
    foreach my $longer (keys %shorter_names) {
        if ($short_name =~ /$longer/) {
            die "Instead of $longer, use $shorter_names{$longer}";
        }
    }

    $r->{short_name} = $short_name;
    $r->{seen}{short_name} = 1;
}

sub recipe_add_severity
{
    my $r = shift;
    my $severity = shift;

    die 'Internal: bad severity value' unless $severity =~ /^(ERROR|WARNING)$/;

    die 'Unable to redefine severity' if $r->{seen}{severity};
    $r->{severity} = $severity;
    $r->{seen}{severity} = 1;
}

sub recipe_add_linter_ids
{
    my $r = shift;
    my $linter_ids = shift;

    die 'Unable to redefine linter_ids' if $r->{seen}{linter_ids};
    push @{$r->{linter_ids}}, map {
        die "Bad linter ID format: $_" unless /^[A-Za-z]+$/;
        $_;
    } @$linter_ids;
    $r->{seen}{linter_ids} = 1;
}

sub recipe_check_if_skip_section
{
    my $r = shift;
    my $section = shift;
    my $skip_list = shift;

    if (exists $skip_list->{$r->{id}} && $skip_list->{$r->{id}}{$section}) {
        if ($skip_list->{$r->{id}}{$section} eq 'skip') {
            return 1;
        }
    }
    return 0;
}

sub recipe_add_see_also_ref
{
    my $r = shift;
    my $ref = shift;

    if (grep { $_ == $ref } @{$r->{see_also}}) {
        die "Ref to $ref is already present";
    }

    push @{$r->{see_also}}, $ref;
}

sub recipe_assert
{
    my $r = shift;
    my $skip_list = shift;

    die 'No recipe id' if !$r->{id};
    die "$r->{id}: No brief description" if $r->{desc_brief} eq '';
    die "$r->{id}: No detailed description" if $r->{desc_detailed} eq '';
    die "$r->{id}: No short name" if $r->{short_name} eq '';
    die "$r->{id}: No severity level" unless defined $r->{severity};
    die "$r->{id}: No linter IDs" if @{$r->{linter_ids}} == 0;
    if (@{$r->{code_bad}} == 0 && !$skip_list_snippets{$r->{id}}{code_bad}) {
        die "$r->{id}: No non-compliant example"
            unless recipe_check_if_skip_section($r, 'code_bad', $skip_list);
    }
    if (@{$r->{code_ok}} == 0 && !$skip_list_snippets{$r->{id}}{code_ok}) {
        die "$r->{id}: No compliant example";
    }

    return $r;
}

sub asssert_license
{
    my ($fh) = @_;
    my @license = (
        '..',
        '    Copyright (c) 2021-2024 Huawei Device Co., Ltd.',
        '    Licensed under the Apache License, Version 2.0 (the "License");',
        '    you may not use this file except in compliance with the License.',
        '    You may obtain a copy of the License at',
        '    http://www.apache.org/licenses/LICENSE-2.0',
        '    Unless required by applicable law or agreed to in writing, software',
        '    distributed under the License is distributed on an "AS IS" BASIS,',
        '    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.',
        '    See the License for the specific language governing permissions and',
        '    limitations under the License.'
    );

    foreach (@license) {
        my $line = <$fh>;
        chomp $line;
        die "Invalid license message: got \'$line\', but expected \'$_\'" unless $line eq $_;
    }
}

sub assert_recipes
{
    my $fname = shift;

    my %recipe;
    my $previous_line = '';
    my $current_recipe;
    my $current_section = 'intro';

    my $in_comment = false;

    my %skip_list = (
        151 => { code_bad => 'skip' },
    );

    open my $FH_r, '<', $fname or die "Cannot open file: $!";

    # license message verification
    asssert_license($FH_r);

    # loop for recipes verification
    while (my $line = <$FH_r>) {
        chomp $line;

        # Common checks:
        die 'Line cannot consist of only white spaces' if $line =~ /^\s+$/;
        die 'Line cannot have trailing white spaces' if $line =~ /\s+$/;
        die 'Line cannot contain \t, change to four spaces' if $line =~ /\t/;
        die 'Line cannot contain FIXME' if $line =~ /\bFIXME\b/i;
        die 'Line cannot contain TBD' if $line =~ /\bTBD\b/i;

        if ($line =~ /^\.\. :comment-begin:/) {
            $in_comment = true;
        } elsif ($line =~ /^\.\. :comment-end:/) {
            $in_comment = false;
        } elsif ($line =~ /^\s*(=+)$/) {
            # $current_section should not change
            my $payload = $1;
            die 'Garbage found in what looks like a header'
                unless $line eq $payload;
            die 'Length mismatch between header and its underline'
                unless length($payload) == length($previous_line);
            die 'Header found in the unexpected place'
                unless $previous_line eq 'Recipes';
        } elsif ($line =~ /^\s*(-+)$/) {
            # $current_section should not change
            my $payload = $1;
            die 'Garbage found in what looks like a header'
                unless $line eq $payload;
            die 'Length mismatch between header and its underline'
                unless length($payload) == length($previous_line);
            die 'Header found in the unexpected place'
                unless $previous_line =~ /\|CB_R\|/;
        } elsif ($line =~ /^\s*(~+)$/) {
            # $current_section should not change
            my $payload = $1;
            die 'Garbage found in what looks like a header'
                unless $line eq $payload;
            die 'Length mismatch between header and its underline'
                unless length($payload) == length($previous_line);
            die 'Header found in the unexpected place'
                unless $previous_line =~ /\|CB_(RULE|BAD|OK|SEE|NON_COMPLIANT_CODE|COMPLIANT_CODE)\|/;
        } elsif ($line eq '.. _Recipes:') {
            # $current_section should not change
            die 'Recipes anchor should be in intro section'
                unless $current_section eq 'intro';
        } elsif ($line =~ /^\s*(\.\.\s+_.+?:)$/) {
            my $payload = $1;
            die 'Garbage found in what looks like a recipe anchor'
                unless $line eq $payload;

            $current_section = 'id';

            die 'Expected markup: .. _RNNN:' if $line !~ /^\.\. _R(\d{3}):$/;
            my $new_id = 0+ $1;

            if (defined $current_recipe) {
                $recipe{$current_recipe->{id}} = recipe_assert($current_recipe, \%skip_list);
            }

            die "Recipe $new_id already exists" if exists $recipe{$new_id};
            $current_recipe = recipe_init($new_id);
        } elsif ($line =~ /^\|CB_R\|.+$/) {
            die 'Expected preceding section: id' if $current_section ne 'id';

            $current_section = 'desc_brief';

            die 'Expected markup: |CB_R| Description'
                unless $line =~ /^\|CB_R\| (\S.+)$/;
            my $desc_brief = $1;
            recipe_add_desc_brief($current_recipe, $desc_brief);
        } elsif ($line =~ /^\|CB_RULE\|.+?$/) {
            die 'Expected preceding section: desc_brief'
                unless $current_section eq 'desc_brief';

            $current_section = 'desc_detailed';

            die 'Expected markup: |CB_RULE| ``arkts-short-name``'
                unless $line =~ /^\|CB_RULE\| ``(arkts-[a-z0-9-]+?)``$/;
            my $short_name = $1;
            recipe_add_short_name($current_recipe, $short_name);
        } elsif ($line =~ /^\.\. meta:$/) {
            # $current_section should not change
            die 'Expected current section: desc_detailed'
                unless $current_section eq 'desc_detailed';
        } elsif ($line =~ /^ {4}:keywords:\s+(.+)$/) {
            # $current_section should not change
            my @linter_ids = split /\s*,\s*/, $1;
            die 'Expected current section: desc_detailed'
                unless $current_section eq 'desc_detailed';

            recipe_add_linter_ids($current_recipe, \@linter_ids);
        } elsif ($line =~ /^ {4}:fix:\s+(.+)$/) {
            # $current_section should not change
            die 'Expected current section: desc_detailed'
                unless $current_section eq 'desc_detailed';
        } elsif ($line =~ /^\|CB_(ERROR|WARNING)\|$/) {
            # $current_section should not change
            my $severity = $1;
            die 'Expected current section: desc_detailed'
                unless $current_section eq 'desc_detailed';
            die "CB_$severity is misplaced" if
                @{$current_recipe->{$current_section}} != 2 ||
                $current_recipe->{$current_section}[0] ne '';
            recipe_add_severity($current_recipe, $severity);
        } elsif ($line =~ /^\|CB_(BAD|NON_COMPLIANT_CODE)\|$/) {
            die 'Expected preceding section: desc_detailed'
                unless $current_section eq 'desc_detailed';

            $current_section = 'code_bad';

            die "Unable to redefine $current_section"
                if $current_recipe->{seen}{$current_section};
            $current_recipe->{seen}{$current_section} = 1;
        } elsif ($line =~ /^\|CB_(OK|COMPLIANT_CODE)\|$/) {
            my $is_in_skip_list = recipe_check_if_skip_section($current_recipe, 'code_bad', \%skip_list);
            die 'Expected preceding section: code_bad'
                unless $current_section eq 'code_bad' || $is_in_skip_list;

            $current_section = 'code_ok';

            die "Unable to redefine $current_section"
                if $current_recipe->{seen}{$current_section};
            $current_recipe->{seen}{$current_section} = 1;
        } elsif ($line =~ /^\|CB_SEE\|$/) {
            die 'Expected preceding sections: desc_detailed, code_bad, code_ok'
                unless $current_section =~ /^(desc_detailed|code_bad|code_ok)$/;

            $current_section = 'see_also';

            die "Unable to redefine $current_section"
                if $current_recipe->{seen}{$current_section};
            $current_recipe->{seen}{$current_section} = 1;
        } elsif ($line =~ /^\s*(\.\.\s*code.+?::.+)$/) {
            # $current_section should not change
            my $payload = $1;
            die 'Garbage found in what looks like a code-block'
                unless $line eq $payload;
            die 'Expected current section: code_bad, code_ok'
                unless $current_section =~ /^(code_bad|code_ok)$/;
            die 'Expected markup: .. code-block:: typescript'
                unless $line =~ /^\.\. code-block:: typescript$/;
            die '.. code-block marker cannot be used more than once'
                if $current_recipe->{seen}{"${current_section}_block"};

            $current_recipe->{seen}{"${current_section}_block"} = 1;
        } elsif ($line =~ /^\s*(\*\s+:ref:`.+?`)$/) {
            # $current_section should not change
            my $payload = $1;
            die 'Garbage found in what looks like a see_also ref'
                unless $line eq $payload;
            die 'Expected current section: see_also'
                unless $current_section eq 'see_also';
            die 'Expected markup: * :ref:`RNNN`'
                unless $line =~ /^\* :ref:`R(\d{3})`$/;

            my $ref = 0+ $1;
            recipe_add_see_also_ref($current_recipe, $ref);
        } elsif (!$in_comment) {
            # $current_section should not change
            # Content line (including empty lines):

            if (length($line) > 0) {
                # Pure content line (no empty lines):
                die 'Content line outside of: intro, desc_detailed, code_bad, code_ok'
                    if $current_section !~ /^(intro|desc_detailed|code_bad|code_ok)$/;
                die 'Content line is longer than 80 characters'
                    if $current_section =~ /^(intro|desc_detailed)$/
                    && length($line) > 80;
                die 'Code line must be indented with at least 4 spaces'
                    if $current_section =~ /^(code_bad|code_ok)$/
                    && $line !~ /^ {4}/;
                #die 'Content line contains unexpected indentation'
                #    if $current_section !~ /^(code_bad|code_ok)$/
                #    && $line =~ /^\s+/;
                die 'Content line contains CB_SOMETHING, most probably a typo'
                    if $line =~ /\|?CB_.+?\|?/;
                die 'Content line contains :ref:, most probably a typo'
                    if $line =~ /:ref:/;
                die 'Content line contains .. code, most probably a typo'
                    if $line =~ /\.\.\s*code(?:-block)?/;
                die "Content line \'$line\' contains .., most probably misplaced markup"
                    if $line =~ /^\.\./;
            }

            if ($current_section =~ /^(desc_detailed|code_bad|code_ok)$/) {
                push @{$current_recipe->{$current_section}}, $line;
            }
        }

        $previous_line = $line;
    }

    # EOF, process the last recipe:
    die 'No recipes were parsed' unless defined $current_recipe;
    recipe_assert($current_recipe, \%skip_list);
    $recipe{$current_recipe->{id}} = $current_recipe;

    close $FH_r;

    return \%recipe;
}

sub assert_ref_consistency
{
    my $recipes = shift;

    my $at_least_one_error = 0;
    foreach my $id (sort { $a <=> $b } keys %$recipes) {
        my $r = $recipes->{$id};
        foreach my $ref (@{$r->{see_also}}) {
            if ($ref == $id) {
                warn "Recipe $id references itself";
                $at_least_one_error = 1;
            }
            unless (exists $recipes->{$ref}) {
                warn "Recipe $id references non-existent recipe $ref";
                $at_least_one_error = 1;
            }
        }
    }
    die 'Checking link consistency failed' if $at_least_one_error;
}

sub assert_short_names
{
    my $recipes = shift;

    my %short_name;
    foreach my $id (sort { $a <=> $b } keys %$recipes) {
        my $r = $recipes->{$id};
        die "$r->{short_name} is not unique"
            if exists $short_name{$r->{short_name}};
        $short_name{$r->{short_name}} = 1;
    }
}

sub compile_snippet
{
    my $r = shift;
    my $section = shift;
    my $skip_list = shift;

    die 'Internal: bad section' unless $section =~ /^(code_bad|code_ok)$/;

    # NB! No "fancy" tmp dir name to avoid dependencies.
    # Please fix if this becomes an issue.
    my $dir_name = '/tmp/recipes-tsc-check';
    mkdir $dir_name if !-d $dir_name;
    my $fname = sprintf '%s/%03d_%s.ts', $dir_name, $r->{id}, $section;

    my $code = join "\n", @{$r->{$section}};

    open my $FH_code, '>', $fname;
    say $FH_code $code;
    close $FH_code;

    # NB! tsc is hardcoded. Please fix if this becomes an issue.
    my $tsc_output = `tsc --strict --target ES2020 --lib es2020,dom $fname`;
    my $ec = $?;

    if (exists $skip_list->{$r->{id}} && $skip_list->{$r->{id}}{$section}) {
        if ($skip_list->{$r->{id}}{$section} eq 'skip') {
            return 1;
        }
        if ($skip_list->{$r->{id}}{$section} eq 'expect_ok' && $ec != 0) {
            warn "Unexpected compile-time error $r->{id}: $section\n$tsc_output";
            return 0;
        }
        if ($skip_list->{$r->{id}}{$section} eq 'expect_fail' && $ec == 0) {
            warn "Unexpected compile-time success $r->{id}: $section\n$tsc_output";
            return 0;
        }
    } else {
        if ($ec != 0 && !grep(/Compile-time error/, $code)) {
            warn "Unexpected compile-time error $r->{id}: $section\n$tsc_output";
            return 0;
        }
        if ($ec == 0 && grep(/Compile-time error/, $code)) {
            warn "Unexpected compile-time success $r->{id}: $section\n$tsc_output";
            return 0;
        }
    }
    return 1;
}

sub assert_code_snippets
{
    my $recipes = shift;

    my %skip_list = (
        8 => { code_bad => 'skip', code_ok => 'skip' },

        55 => { code_ok => 'expect_ok' },
        65 => { code_ok => 'expect_ok' },

        135 => { code_bad => 'skip' },

        # Recipes for import / export, require smart recheck:
        118 => { code_bad => 'skip', code_ok => 'skip' },
        119 => { code_bad => 'skip', code_ok => 'skip' },
        120 => { code_bad => 'skip', code_ok => 'skip' },
        121 => { code_bad => 'skip', code_ok => 'skip' },
        126 => { code_bad => 'skip', code_ok => 'skip' },
        128 => { code_bad => 'skip', code_ok => 'skip' },
        129 => { code_bad => 'skip', code_ok => 'skip' },
        130 => { code_bad => 'skip', code_ok => 'skip' },
        133 => { code_bad => 'skip', code_ok => 'skip' },
        137 => { code_bad => 'skip', code_ok => 'skip' },
        143 => { code_bad => 'skip', code_ok => 'skip' },
        147 => { code_bad => 'skip', code_ok => 'skip' },
        150 => { code_bad => 'skip', code_ok => 'skip' },

        # Recipe for ESObject:
        151 => { code_ok => 'skip' },

        # Recipes for Sendable API restrictions:
        153 => { code_bad => 'skip', code_ok => 'skip' },
        154 => { code_bad => 'skip', code_ok => 'skip' },
        155 => { code_bad => 'skip', code_ok => 'skip' },
        156 => { code_bad => 'skip', code_ok => 'skip' },
        157 => { code_bad => 'skip', code_ok => 'skip' },
        158 => { code_bad => 'skip', code_ok => 'skip' },
        159 => { code_bad => 'skip', code_ok => 'skip' },
        160 => { code_bad => 'skip', code_ok => 'skip' },
        161 => { code_bad => 'skip', code_ok => 'skip' },
        162 => { code_bad => 'skip', code_ok => 'skip' },
        163 => { code_bad => 'skip', code_ok => 'skip' },
        164 => { code_bad => 'skip', code_ok => 'skip' },
    );

    my $at_least_one_error = 0;
    foreach my $id (sort { $a <=> $b } keys %$recipes) {
        my $r = $recipes->{$id};
        my $r_bad = compile_snippet($r, 'code_bad', \%skip_list);
        $at_least_one_error = 1 unless $r_bad;

        my $r_ok = compile_snippet($r, 'code_ok', \%skip_list);
        $at_least_one_error = 1 unless $r_ok;
    }
    die 'Failed tsc validation' if $at_least_one_error;
}

sub dump_csv_process_multiline
{
    my $r = shift;
    my $section = shift;

    die 'Internal: bad section'
        unless $section =~ /^(desc_detailed|code_bad|code_ok)$/;

    my $delimiter = $section =~ /^(code_bad|code_ok)$/ ? "\n" : ' ';
    my $text = join $delimiter, map { s/^ {4}//; $_ } @{$r->{$section}};

    $text =~ s/^\s+//;
    $text =~ s/\s+$//;
    $text =~ s/"/""/g;

    return $text;
}

sub dump_csv
{
    my $recipes = shift;
    my $fname = shift;

    my @headers = (
        'ID',
        'Short Name',
        'Linter IDs',
        'Severity',
        'Summary',
        'Description',
        'Non-compliant code',
        'Compliant code',
    );
    my $format = join ',', map { q/"%s"/ } (1 .. scalar @headers);

    open my $FH_csv, '>', $fname or die "Cannot open file: $!";
    say $FH_csv sprintf($format, @headers);

    foreach my $id (sort { $a <=> $b } keys %$recipes) {
        my $r = $recipes->{$id};
        my $line = sprintf $format,
            # No escaping needed:
            $r->{id},
            $r->{short_name},
            sort(join(', ', @{$r->{linter_ids}})),
            $r->{severity},
            $r->{desc_brief},
            # Escaping needed:
            dump_csv_process_multiline($r, 'desc_detailed'),
            dump_csv_process_multiline($r, 'code_bad'),
            dump_csv_process_multiline($r, 'code_ok'),
        ;
        $line =~ s/\|LANG\|/ArkTS/g;
        $line =~ s/\|TS\|/TypeScript/g;
        $line =~ s/\|JS\|/JavaScript/g;
        $line =~ s/``//g;

        say $FH_csv $line;
    }
    close $FH_csv;
}

#
# Main logic
#

# NB! No fancy options parsing to avoid extra dependencies.
# Please fix if this becomes an issue.
if (grep /^--help$/, @ARGV) {
    say <<HELP
Validator of ArkTS cookbook recipes.

validate-recipes --recipes=/path/to/recipes.rst [OPTIONS]

OPTIONS

--check-code                      Check code snippets with tsc (takes some time)
--dump-csv=/path/to/output.csv    Dump recipes to an Excel-compatible CSV file
--help                            Show this help and exit
HELP
    ;
    exit;
}

my $fname = (grep /^--recipes=.+$/, @ARGV)[0];
die 'No recipes file' unless $fname;
($fname) = ($fname =~ /--recipes=(.+)/);

my $recipes = assert_recipes($fname);

assert_ref_consistency($recipes);

assert_short_names($recipes);

assert_code_snippets($recipes) if grep /^--check-code$/, @ARGV;

my $fname_csv = (grep /^--dump-csv=.+$/, @ARGV)[0];
if ($fname_csv) {
    ($fname_csv) = ($fname_csv =~ /--dump-csv=(.+)/);
    dump_csv($recipes, $fname_csv);
}
